home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / OASGN.R < prev    next >
Encoding:
Text File  |  1992-02-10  |  11.9 KB  |  457 lines
  1. /*
  2.  * File: oasgn.r
  3.  * Asgn - perform an assignment when the destination descriptor might
  4.  *  be within a block.
  5.  */
  6. #define Asgn(dest, src) *(dptr)((word *)VarLoc(dest) + Offset(dest)) = src;
  7.  
  8. /*
  9.  * GeneralAsgn - perform the assignment x := y, where x is known to be
  10.  *  a variable and y is has been dereferenced.
  11.  */
  12. #begdef GeneralAsgn(x, y)
  13.    type_case x of {
  14.       tvsubs: {
  15.         if !cnv:tmp_string(y) then
  16.            runerr(103, y)
  17.         abstract {
  18.            store[store[type(x).str_var]] = string
  19.            }
  20.         inline {
  21.            if (subs_asgn(&x, &y) == Error)
  22.               runerr(0);
  23.            }
  24.         }
  25.       tvtbl: {
  26.         abstract {
  27.            store[store[type(x).trpd_tbl].tbl_elem] = type(y)
  28.            }
  29.         inline {
  30.            tvtbl_asgn(&x, &y);
  31.            }
  32.          }
  33.       kywdint: 
  34.          /*
  35.           * No side effect in the type realm - keyword x is still an int.
  36.           */
  37.          if !cnv:integer(y, *VarLoc(x)) then
  38.             runerr(101, y);
  39.       kywdpos: {
  40.          /*
  41.           * No side effect in the type realm - &pos is still an int.
  42.           */
  43.          body {
  44.             C_integer i;
  45.  
  46.             if (!cnv:C_integer(y, i))
  47.                runerr(101, y);
  48.             i = cvpos((long)i, StrLen(k_subject));
  49.             if (i == CvtFail)
  50.                fail;
  51.             k_pos = i;
  52.             }
  53.          }
  54.       kywdsubj: {
  55.          /*
  56.           * No side effect in the type realm - &subject is still a string
  57.           *  and &pos is still an int.
  58.           */
  59.          if !cnv:string(y, k_subject) then
  60.             runerr(103, y);
  61.          inline {
  62.             k_pos = 1;
  63.             }
  64.          }
  65.       default: {
  66.         abstract {
  67.            store[type(x)] = type(y)
  68.            }
  69.          inline {
  70.             Asgn(x, y)
  71.             }
  72.          }
  73.       }
  74. #enddef
  75.  
  76.  
  77. "x := y - assign y to x."
  78.  
  79. operator{0,1} := asgn(underef x, y)
  80.  
  81.    if !is:variable(x) then
  82.       runerr(111, x)
  83.  
  84.    abstract {
  85.       return type(x)
  86.       }
  87.  
  88.    GeneralAsgn(x, y)
  89.  
  90.    inline {
  91.       /*
  92.        * The returned result is the variable to which assignment is being
  93.        *  made.
  94.        */
  95.       return x;
  96.       }
  97. end
  98.  
  99.  
  100. "x <- y - assign y to x."
  101. " Reverses assignment if resumed."
  102.  
  103. operator{0,1+} <- rasgn(underef x -> saved_x, y)
  104.  
  105.    if !is:variable(x) then
  106.       runerr(111, x)
  107.  
  108.    abstract {
  109.       return type(x)
  110.       }
  111.  
  112.    GeneralAsgn(x, y)
  113.  
  114.    inline {
  115.       suspend x;
  116.       }
  117.  
  118.    GeneralAsgn(x, saved_x)
  119.  
  120.    inline {
  121.       fail;
  122.       }
  123. end
  124.  
  125.  
  126. "x <-> y - swap values of x and y."
  127. " Reverses swap if resumed."
  128.  
  129. operator{0,1+} <-> rswap(underef x -> dx, underef y -> dy)
  130.  
  131.    declare {
  132.       tended union block *bp_x, *bp_y;
  133.       word adj1 = 0;
  134.       word adj2 = 0;
  135.       }
  136.  
  137.    if !is:variable(x) then
  138.       runerr(111, x)
  139.    if !is:variable(y) then
  140.       runerr(111, y)
  141.  
  142.    abstract {
  143.       return type(x)
  144.       }
  145.  
  146.    if is:tvsubs(x) && is:tvsubs(y) then
  147.       body {
  148.          bp_x = BlkLoc(x);
  149.          bp_y = BlkLoc(y);
  150.          if (VarLoc(bp_x->tvsubs.ssvar) == VarLoc(bp_y->tvsubs.ssvar) &&
  151.          Offset(bp_x->tvsubs.ssvar) == Offset(bp_y->tvsubs.ssvar)) {
  152.             /*
  153.              * x and y are both substrings of the same string, set
  154.              *  adj1 and adj2 for use in locating the substrings after
  155.              *  an assignment has been made.  If x is to the right of y,
  156.              *  set adj1 := *x - *y, otherwise if y is to the right of
  157.              *  x, set adj2 := *y - *x.  Note that the adjustment
  158.              *  values may be negative.
  159.              */
  160.             if (bp_x->tvsubs.sspos > bp_y->tvsubs.sspos)
  161.                adj1 = bp_x->tvsubs.sslen - bp_y->tvsubs.sslen;
  162.             else if (bp_y->tvsubs.sspos > bp_x->tvsubs.sspos)
  163.                adj2 = bp_y->tvsubs.sslen - bp_x->tvsubs.sslen;
  164.            }
  165.          }
  166.  
  167.    /*
  168.     * Do x := y
  169.     */
  170.    GeneralAsgn(x, dy)
  171.  
  172.    if is:tvsubs(x) && is:tvsubs(y) then
  173.       inline {
  174.          if (adj2 != 0)
  175.             /*
  176.              * Arg2 is to the right of Arg1 and the assignment Arg1 := Arg2 has
  177.              *  shifted the position of Arg2.  Add adj2 to the position of Arg2
  178.              *  to account for the replacement of Arg1 by Arg2.
  179.              */
  180.             bp_y->tvsubs.sspos += adj2;
  181.          }
  182.  
  183.    /*
  184.     * Do y := x
  185.     */
  186.    GeneralAsgn(y, dx)
  187.  
  188.    if is:tvsubs(x) && is:tvsubs(y) then
  189.       inline {
  190.          if (adj1 != 0)
  191.             /*
  192.              * Arg1 is to the right of Arg2 and the assignment Arg2 := Arg1
  193.              *  has shifted the position of Arg1.  Add adj2 to the position
  194.              *  of Arg1 to account for the replacement of Arg2 by Arg1.
  195.              */
  196.             bp_x->tvsubs.sspos += adj1;
  197.          }
  198.  
  199.    inline {
  200.       suspend x;
  201.       }
  202.    /*
  203.     * If resumed, the assignments are undone.  Note that the string position
  204.     *  adjustments are opposite those done earlier.
  205.     */
  206.    GeneralAsgn(x, dx)
  207.    if is:tvsubs(x) && is:tvsubs(y) then
  208.       inline {
  209.          if (adj2 != 0)
  210.            bp_y->tvsubs.sspos -= adj2;
  211.          }
  212.  
  213.    GeneralAsgn(y, dy)
  214.    if is:tvsubs(x) && is:tvsubs(y) then
  215.       inline {
  216.          if (adj1 != 0)
  217.             bp_x->tvsubs.sspos -= adj1;
  218.          }
  219.  
  220.    inline {
  221.       fail;
  222.       }
  223. end
  224.  
  225.  
  226. "x :=: y - swap values of x and y."
  227.  
  228. operator{0,1} :=: swap(underef x -> dx, underef y -> dy)
  229.    declare {
  230.       tended union block *bp_x, *bp_y;
  231.       word adj1 = 0;
  232.       word adj2 = 0;
  233.       }
  234.  
  235.    /*
  236.     * x and y must be variables.
  237.     */
  238.    if !is:variable(x) then
  239.       runerr(111, x)
  240.    if !is:variable(y) then
  241.       runerr(111, y)
  242.  
  243.    abstract {
  244.       return type(x)
  245.       }
  246.  
  247.    if is:tvsubs(x) && is:tvsubs(y) then
  248.       body {
  249.          bp_x = BlkLoc(x);
  250.          bp_y = BlkLoc(y);
  251.          if (VarLoc(bp_x->tvsubs.ssvar) == VarLoc(bp_y->tvsubs.ssvar) &&
  252.          Offset(bp_x->tvsubs.ssvar) == Offset(bp_y->tvsubs.ssvar)) {
  253.             /*
  254.              * x and y are both substrings of the same string, set
  255.              *  adj1 and adj2 for use in locating the substrings after
  256.              *  an assignment has been made.  If x is to the right of y,
  257.              *  set adj1 := *x - *y, otherwise if y is to the right of
  258.              *  x, set adj2 := *y - *x.  Note that the adjustment
  259.              *  values may be negative.
  260.              */
  261.             if (bp_x->tvsubs.sspos > bp_y->tvsubs.sspos)
  262.                adj1 = bp_x->tvsubs.sslen - bp_y->tvsubs.sslen;
  263.             else if (bp_y->tvsubs.sspos > bp_x->tvsubs.sspos)
  264.                adj2 = bp_y->tvsubs.sslen - bp_x->tvsubs.sslen;
  265.            }
  266.          }
  267.  
  268.    /*
  269.     * Do x := y
  270.     */
  271.    GeneralAsgn(x, dy)
  272.  
  273.    if is:tvsubs(x) && is:tvsubs(y) then
  274.       inline {
  275.          if (adj2 != 0)
  276.             /*
  277.              * Arg2 is to the right of Arg1 and the assignment Arg1 := Arg2 has
  278.              *  shifted the position of Arg2.  Add adj2 to the position of Arg2
  279.              *  to account for the replacement of Arg1 by Arg2.
  280.              */
  281.             bp_y->tvsubs.sspos += adj2;
  282.          }
  283.  
  284.    /*
  285.     * Do y := x
  286.     */
  287.    GeneralAsgn(y, dx)
  288.  
  289.    if is:tvsubs(x) && is:tvsubs(y) then
  290.       inline {
  291.          if (adj1 != 0)
  292.             /*
  293.              * Arg1 is to the right of Arg2 and the assignment Arg2 := Arg1
  294.              *  has shifted the position of Arg1.  Add adj2 to the position
  295.              *  of Arg1 to account for the replacement of Arg2 by Arg1.
  296.              */
  297.             bp_x->tvsubs.sspos += adj1;
  298.          }
  299.  
  300.    inline {
  301.       return x;
  302.       }
  303. end
  304.  
  305. /*
  306.  * subs_asgn - preform assignment to a substring. Leave the updated substring
  307.  *  in dest in case it is needed as the result of the assignment.
  308.  */
  309. int subs_asgn(dest, src)
  310. dptr dest;
  311. dptr src;
  312.    {
  313.    tended struct descrip deststr;
  314.    tended struct descrip rsltstr;
  315.    tended struct b_tvsubs *tvsub;
  316.  
  317.    word prelen;   /* length of portion of string before substring */
  318.    word poststrt; /* start of portion of string following substring */
  319.    word postlen;  /* length of portion of string following substring */
  320.  
  321.    /*
  322.     * Be sure that the variable in the trapped variable points
  323.     *  to a string and that the string is big enough to contain
  324.     *  the substring.
  325.     */
  326.    tvsub = (struct b_tvsubs *)BlkLoc(*dest);
  327.    deref(&tvsub->ssvar, &deststr);
  328.    if (!is:string(deststr))
  329.       ReturnErrVal(103, deststr, Error);
  330.    prelen = tvsub->sspos - 1;
  331.    poststrt = prelen + tvsub->sslen;
  332.    if (poststrt > StrLen(deststr))
  333.       ReturnErrNum(205, Error);
  334.  
  335.    /*
  336.     * Form the result string.
  337.     */
  338. #ifdef MultiRegion
  339.    if (!strreserve(prelen + StrLen(*src) + StrLen(deststr) - poststrt))
  340.       return Error;
  341. #endif                        /* MultiRegion */
  342.  
  343.    /*
  344.     * First, copy the portion of the substring string to the left of
  345.     *  the substring into the string space.
  346.     */
  347.    Protect(StrLoc(rsltstr) = alcstr(StrLoc(deststr), prelen), return Error);
  348.    StrLen(rsltstr) = prelen;
  349.  
  350.    /*
  351.     * Copy the string to be assigned into the string space,
  352.     *  effectively concatenating it.
  353.     */
  354.    Protect(alcstr(StrLoc(*src), StrLen(*src)), return Error);
  355.    StrLen(rsltstr) += StrLen(*src);
  356.  
  357.    /*
  358.     * Copy the portion of the substring to the right of
  359.     *  the substring into the string space, completing the
  360.     *  result.
  361.     */
  362.    postlen = StrLen(deststr) - poststrt;
  363.    Protect(alcstr(StrLoc(deststr) + poststrt, postlen), return Error);
  364.    StrLen(rsltstr) += postlen;
  365.  
  366.  
  367.    /*
  368.     * Perform the assignment and update the trapped variable.
  369.     */
  370.    if (is:kywdsubj(tvsub->ssvar))
  371.       *VarLoc(tvsub->ssvar) = rsltstr;
  372.    else
  373.       Asgn(tvsub->ssvar, rsltstr)
  374.    tvsub->sslen = StrLen(*src);
  375.    return Succeeded;
  376.    }
  377.  
  378. /*
  379.  * tvtbl_asgn - perform an assignment to a table element trapped variable,
  380.  *  inserting the element in the table if needed.
  381.  */
  382. novalue tvtbl_asgn(dest, src)
  383. dptr dest;
  384. dptr src;
  385.    {
  386.    /*
  387.     * No allocations are performed until the end, so nothing need be tended.
  388.     */
  389.    union block *bp;
  390.    union block *ep;
  391.    union block *hook;
  392.    union block **slot;
  393.    struct b_table *tp;
  394.    struct descrip d;
  395.    register uword hn;
  396.  
  397.    /*
  398.     * If already a table element, not a trapped variable, just assign and
  399.     *  return.
  400.     */
  401.    bp = BlkLoc(*dest);
  402.    if (bp->tvtbl.title == T_Telem) {
  403.        bp->telem.tval = *src;
  404.        return;
  405.     }
  406.  
  407.    /*
  408.     * Convert the trapped-variable block into a table-element block
  409.     *  and insert it in the table.  Begin by getting the hash number
  410.     *  for the subscripting value and locating the correct hash chain.
  411.     */
  412.  
  413.    tp = (struct b_table *) bp->tvtbl.clink;
  414.    hn = bp->tvtbl.hashnum;
  415.    slot = hchain((union block *)tp, hn);
  416.    ep = *slot;
  417.  
  418.    /*
  419.     * Traverse the chain to see if the value is already in the
  420.     *  table.  If it is there, assign to it and return.
  421.     */
  422.    hook = ep;
  423.    while (ep != NULL && ep->telem.hashnum <= hn) {
  424.       if (ep->telem.hashnum == hn
  425.         && equiv(&ep->telem.tref, &bp->tvtbl.tref)) {
  426.            bp->telem.tval = *src;    /* found it! */
  427.                return;
  428.                }
  429.       hook = ep;
  430.       ep = ep->telem.clink;
  431.       }
  432.  
  433.    /*
  434.     * The value being assigned is new.  Increment the table
  435.     *  size, convert the table-element trapped-variable block
  436.     *  to a table-element block, and link it into the chain.
  437.     */
  438.    tp->size++;
  439.    if (hook == ep) {            /* it goes at front of chain */
  440.       bp->telem.clink = *slot;
  441.       *slot = bp;
  442.       }
  443.    else {                /* it follows hook */
  444.       bp->telem.clink = hook->telem.clink;
  445.       hook->telem.clink = bp;
  446.       }
  447.  
  448.    bp->tvtbl.title = T_Telem;        /* mutate b_tvtbl into b_telem */
  449.    bp->telem.tval = *src;        /* set the value */
  450.    d.dword = D_Telem;
  451.    BlkLoc(d) = (union block *)bp;
  452.    MMShow(&d, 'r');            /* record mutation event */
  453.  
  454.    if (TooCrowded(tp))            /* grow hash table if now too full */
  455.       hgrow((union block *)tp);
  456.    }
  457.